This is practics case based on some data from kaggle
I mostly made this to play around with some data and learn new methods. When working with data, like many others, I like to use either R Markdown or Jupyter Notebook. I also enjoy writing small notes and comments so that if I need to revisit the project later, I can easily see what I did. This approach is really helpful in terms of reproducibility. Unfortunately, people often share notebooks without adding any text or comments.
While I’ve written out some comments here, I don’t go too deep. However, I do show parts of my workflow. The code is written in R, and I consider it what I call “one-time code.” It’s not meant to be read by others. It’s not optimized either—I’ve simply chosen the fastest code I could think of or find to solve a problem. I ende op using Chat-gbt for some code aswell then correcting the mistakes. The methology and the models chosen is all me.
The goal is to achieve the lowest score on the out-of-sample prediction set based on a specific metric.
Let \(P_{id}\) represent the price of a given house identified by \(id\).
The metric used for scoring is the Root Mean Squared Deviation (RMSD) of logarithmic prices:
\[RMSD(\log(\hat{P}_{id})) = \sqrt{\frac{\sum_{id} (\log(P_{id}) - \log(\hat{P}_{id}))^2}{N}}\]
The logarithm is applied to ensure that expensive houses are not prioritized disproportionately. Without this adjustment, the model might prioritize expensive houses because the same proportional change in price would result in a larger numerical difference for higher-priced properties.
(While this argument makes sense, it seems like the ratio of expensive to “cheap” houses in the dataset might also affect this outcome.)
(Nevertheless, this is the metric used by all other candidates, so if I want to compare my score with theirs, I must use it.)
When conducting the analysis, the square root is typically omitted. This simplification does not affect the results, as the square root is a monotonically increasing function. Therefore, for model selection, the choice remains unaffected.
Their is detail data description here, on krangler af in textfile with the data.
I have copied the description of the covariates.
Predictor varibels
library(readr)
df=as.data.frame(read.csv("train.csv"))
#split <- sample(1:nrow(df), size = 0.8 * nrow(df))
# Create training and testing sets
#df <- df[split, ] # 80% of the data
#df_test_for_choice <- df[-split, ] # other 20%
#
df_test_preformence=as.data.frame(read.csv("test.csv"))In the description, I noticed that some of the variables use NA as a category.
Varibels where NA is a catgori is listed below.
These variables need to be recoded, as the values are not missing—they are simply in the wrong format.
#change
chang_to_df<-function(DF){
DF$Alley<-DF$Alley[is.na(DF$Alley)] <- "No alley"
DF$BsmtQual[is.na(DF$BsmtQual)]<-"No Basement"
DF$BsmtCond[is.na(DF$BsmtCond)]<-"No Basement"
DF$BsmtExposure[is.na(DF$BsmtExposure)]<-"No Basement"
DF$BsmtFinType1[is.na(DF$BsmtFinType1)]<- "No Basement"
DF$BsmtFinType2[is.na(DF$BsmtFinType2)]<- "No Basement"
DF$FireplaceQu[is.na(DF$FireplaceQu)]<-"No Fireplace"
DF$GarageType[is.na(DF$GarageType)]<-"No Garage"
DF$GarageFinish[is.na(DF$GarageFinish)]<-"No Garage"
DF$GarageQual[is.na(DF$GarageQual)]<-"No Garage"
DF$GarageCond[is.na(DF$GarageCond)]<-"No Garage"
DF$GarageYrBlt[is.na(DF$GarageYrBlt)]<-0 # all values that is NA corespond wither other showing that their is no garage.
DF$PoolQC[is.na(DF$PoolQC)]<-"No Pool"
DF$Fence[is.na(DF$Fence)]<-"No Fence"
DF$MiscFeature[is.na(DF$MiscFeature)]<-"None"
return(DF)
}
df<-chang_to_df(df)
#df_test_for_choice<-chang_to_df(df_test_for_choice)
df_test_preformence<-chang_to_df(df_test_preformence)After recoding cases where NA does not represent missing values, we will now analyze the actual missing values.
Below is a plot showing the missing values. I had to split the plot into two parts; otherwise, the variable names would not be readable.
library(naniar)
vis_miss(df[,1:40])
vis_miss(df[,40:81])
LotFrontage missing values look weird.
The definition is Linear feet of street connected to property. Below i have printed uniqe entreances in LotFrontage.
table((df$LotFrontage))
21 24 30 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48
23 19 6 5 1 10 9 6 5 1 1 12 6 4 12 9 3 1 5 6
49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68
4 57 15 14 10 6 17 5 12 7 13 143 8 9 17 19 44 15 12 19
69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88
11 70 12 17 18 15 53 11 9 25 17 69 6 12 5 9 40 10 5 10
89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108
6 23 6 10 8 6 7 8 2 8 3 16 2 4 3 3 6 1 7 3
109 110 111 112 114 115 116 118 120 121 122 124 128 129 130 134 137 138 140 141
2 6 1 1 2 2 2 2 7 2 2 2 1 2 3 2 1 1 1 1
144 149 150 152 153 160 168 174 182 313
1 1 1 1 1 1 1 2 1 2 From the definition, it could refer to farms, but there are no farms in the dataset.
If we plot the house types against the number of missing values, we see that most of them come from single-family detached houses.
library(dplyr)
# Test farm theory
test_LotFrontage <- df$LotFrontage
test_LotFrontage[is.na(test_LotFrontage)] <- 0
test_BldgType <- factor(df$BldgType)
# Create a data frame
data <- data.frame(test_BldgType, test_LotFrontage)
zero_counts <- data %>%
filter(test_LotFrontage == 0) %>%
count(test_BldgType)
# Create the bar plot with category labels at the bottom
barplot(zero_counts$n,
names.arg = zero_counts$test_BldgType, # Use the correct column for labels
main = "Number of Zeros by Category",
xlab = "Categories",
ylab = "Count of Zeros",
col = "lightblue",
las = 2) # Rotate labels to vertical
It seems like most of the missing values are from single-family detached houses, so it’s unrealistic to assume there is no street connected to the property. This means setting the values to zero is likely a bad option.
Options for imputation:
Linear regression based on other variables. k-nearest neighbors. I could also disregard this variable since I doubt it has high predictive power.
It seems like an interactive linear model, incorporating the interaction between LotArea and LotShape, would provide good imputation (this also makes sense conceptually).
Imputasion_model <- lm(LotFrontage ~ LotArea * LotShape, df)
# Plot fitted values vs. residuals
plot(Imputasion_model$fitted.values, Imputasion_model$residuals,
xlab = "Fitted Values",
ylab = "Residuals",
main = "Residuals plot (LotFrontage ~ LotArea * LotShape)")
# Add a horizontal line at the mean of the residuals (which should be zero)
abline(h = mean(Imputasion_model$residuals), col = "red", lwd = 2, lty = 2)
mean_value <- mean(Imputasion_model$residuals)
text(x = max(Imputasion_model$fitted.values),
y = mean_value,
labels = "Mean",
col = "red")
Missing values for LotFrontage will be imputed using the linear model described above.
This also means that if LotFrontage is used in the model, the imputation will need to be performed on the test set as well. I have internally debated whether I should include the test set when building the imputation model—essentially, creating a model based on both the training and test sets for this purpose.
Since I’m a little new to Kaggle, if the test set contains covariates and I only need to upload the fitted values, I would proceed with this approach. Otherwise, I would not. For now, I will just use the model based only on the training set.
# imputatsion
Imputasion_model <- lm(LotFrontage ~ LotArea * LotShape, df)
Input_value<-function(DF){
for (i in 1:length(DF$LotFrontage)){
if(is.na(DF$LotFrontage[i])){
DF$LotFrontage[i]<-predicted_value <- predict(Imputasion_model, newdata = list(
LotArea = DF$LotArea[i],
LotShape = DF$LotShape[i] ))
}
}
return(DF)
}
#input df for all input values
df<-Input_value(df)
#df_test_for_choice<-Input_value(df_test_for_choice)
df_test_preformence<-Input_value(df_test_preformence)There are still 1% of missing values in MasVnrArea and MasVnrType. I will discard the last row containing these missing values.
In this section, I will examine the variable distributions and determine if any transformations or categorizations are necessary. To explore the data, I have created a number of plots for the variables. To make this process more accessible to potential readers, I have developed a small Shiny live application. To run this application live, I need to read the data from an online source, which is hosted on my GitHub page.
I have included the code for the plots, and a potential reader can see in the code where the data is written to a text file.
Some of these variables have a ranking, which makes them well-suited for recoding. By recoding them as numerical values, the ranking becomes more obvious.
To give a exampel of the recoding. PoolQC: Pool quality
Ex Excellent (4)
Gd Good (3)
TA Average/Typical (2) (TA is never obsevered in pool varibel for traning set)
Fa Fair (1)
NA No Pool (0)can be codes as 0-4
Belowe here i have made list of how the varibels is code. I have made is so no pressent cagories NA is code to 0. Meaning 0 is only a value if the item is not pressent. and otherwise it starts from 1.
LotShape: General shape of property Reg Regular (4) IR1 Slightly irregular (3) IR2 Moderately Irregular (2) IR3 Irregular (1)
LandContour: Flatness of the property
Lvl Near Flat/Level (4)
Bnk Banked - Quick and significant rise from street grade to building (3)
HLS Hillside - Significant slope from side to side (2)
Low Depression (1)LandSlope: Slope of property
Gtl Gentle slope (3)
Mod Moderate Slope (2)
Sev Severe Slope (1)ExterQual: Evaluates the quality of the material on the exterior
Ex Excellent (5)
Gd Good (4)
TA Average/Typical (3)
Fa Fair (2)
Po Poor (1)
ExterCond: Evaluates the present condition of the material on the exterior
Ex Excellent (5)
Gd Good (4)
TA Average/Typical (3)
Fa Fair (2)
Po Poor (1)
BsmtQual: Evaluates the height of the basement
Ex Excellent (100+ inches) (5)
Gd Good (90-99 inches) (4)
TA Typical (80-89 inches) (3)
Fa Fair (70-79 inches) (2)
Po Poor (<70 inches (1)
NA No Basement (0)BsmtCond: Evaluates the general condition of the basement
Ex Excellent (5)
Gd Good (4)
TA Typical - slight dampness allowed (3)
Fa Fair - dampness or some cracking or settling (2)
Po Poor - Severe cracking, settling, or wetness (1)
NA No Basement (0)BsmtExposure: Refers to walkout or garden level walls
Gd Good Exposure (4)
Av Average Exposure (split levels or foyers typically score average or above) (3)
Mn Mimimum Exposure (2)
No No Exposure (1)
NA No Basement (0)BsmtFinType1: Rating of basement finished area
GLQ Good Living Quarters (6)
ALQ Average Living Quarters (5)
BLQ Below Average Living Quarters (4)
Rec Average Rec Room (3)
LwQ Low Quality (2)
Unf Unfinshed (1)
NA No Basement (0)BsmtFinType2: Rating of basement finished area (if multiple types)
GLQ Good Living Quarters (6)
ALQ Average Living Quarters (5)
BLQ Below Average Living Quarters (4)
Rec Average Rec Room (3)
LwQ Low Quality (2)
Unf Unfinshed (1)
NA No Basement (0)HeatingQC: Heating quality and condition
Ex Excellent (5)
Gd Good (4)
TA Average/Typical (3)
Fa Fair (2)
Po Poor (1)KitchenQual: Kitchen quality
Ex Excellent (5)
Gd Good (4)
TA Average/Typical (3)
Fa Fair (2)
Po Poor (1)Functional: Home functionality (Assume typical unless deductions are warranted)
Typ Typical Functionality (7)
Min1 Minor Deductions 1 (6)
Min2 Minor Deductions 2 (5)
Mod Moderate Deductions (4)
Maj1 Major Deductions 1 (3)
Maj2 Major Deductions 2 (2)
Sev Severely Damaged (1)
Sal Salvage only (0)
FireplaceQu: Fireplace quality
Ex Excellent - Exceptional Masonry Fireplace (5)
Gd Good - Masonry Fireplace in main level (4)
TA Average - Prefabricated Fireplace in main living area or Masonry Fireplace in basement (3)
Fa Fair - Prefabricated Fireplace in basement (2)
Po Poor - Ben Franklin Stove (1)
NA No Fireplace (0)GarageFinish: Interior finish of the garage
Fin Finished (3)
RFn Rough Finished (2)
Unf Unfinished (1)
NA No Garage (0)
GarageQual: Garage quality
Ex Excellent (5)
Gd Good (4)
TA Typical/Average (3)
Fa Fair (2)
Po Poor (1)
NA No Garage (0)GarageCond: Garage condition
Ex Excellent (5)
Gd Good (4)
TA Typical/Average (3)
Fa Fair (2)
Po Poor (1)
NA No Garage (0)PoolQC: Pool quality
Ex Excellent (4)
Gd Good (3)
TA Average/Typical (2) (TA is never obsevered in pool varibel for traning set)
Fa Fair (1)
NA No Pool (0)
Fence: Fence quality
GdPrv Good Privacy (4)
MnPrv Minimum Privacy (3)
GdWo Good Wood (2)
MnWw Minimum Wood/Wire (1)
NA No Fence (0)# Reencoding can be don via match.
# recoding
recoding<-function(DF){
DF$LotShape<-match(DF$LotShape,c("IR3","IR2","IR1","Reg"))
#DF$LandContour<-match(DF$LandContour,c("Low","HLS","Bnk","Lvl"))
#DF$LandSlope<-match(DF$LandSlope,c("Sev","Mod","Gtl"))
DF$ExterQual<-match(DF$ExterQual,c("Po","Fa","TA","Gd","Ex"))
DF$ExterCond<-match(DF$ExterCond,c("Po","Fa","TA","Gd","Ex"))
DF$BsmtQual<-match(DF$BsmtQual,c("No Basement","Fa","TA","Gd","Ex"))-1
DF$BsmtCond<-match(DF$BsmtCond,c("No Basement","Fa","TA","Gd","Ex"))-1
DF$BsmtExposure<-match(DF$BsmtExposure,c("No Basement","No","Mn","Av","Gd"))-1
DF$BsmtFinType1<-match(DF$BsmtFinType1,c("No Basement","Unf","LwQ","Rec","BLQ","ALQ","GLQ"))-1
DF$BsmtFinType2<-match(DF$BsmtFinType2,c("No Basement","Unf","LwQ","Rec","BLQ","ALQ","GLQ"))-1
DF$HeatingQC<-match(DF$HeatingQ,c("Po","Fa","TA","Gd","Ex"))
DF$KitchenQual<-match(DF$KitchenQual,c("Po","Fa","TA","Gd","Ex"))
DF$Functional<-match(DF$Functional,c("Sal","Sev","Maj2","Maj1","Mod","Min2","Min1","Typ"))-1
DF$FireplaceQu<-match(DF$FireplaceQu,c("No Fireplace","Po","Fa","TA","Gd","Ex"))-1
DF$GarageFinish<-match(DF$GarageFinish,c("No Garage","Unf","RFn","Fin"))-1
DF$GarageQual<-match(DF$GarageQual,c("No Garage","Po","Fa","TA","Gd","Ex"))-1
DF$GarageCond<-match(DF$GarageCond,c("No Garage","Po","Fa","TA","Gd","Ex"))-1
DF$PoolQC<-match(DF$PoolQC, c("No Pool","Fa","TA","Gd","Ex"))-1
#DF$Fence<-match(DF$Fence,c("No Fence","MnWw","GdWo","MnPrv","GdPrv"))-1
return(DF)
}
df<-recoding(df)
#df_test_for_choice<-recoding(df_test_for_choice)
df_test_preformence<-recoding(df_test_preformence)Below is a plot of all the variables. I prefer histograms over boxplots as they provide a better overview of the distribution.
write.csv(df, "data_before_clean.csv", row.names = FALSE)library(ggplot2)
library(purrr)
for (col in names(df)) {
if (is.numeric(df[[col]])) {
# Numeriske variabler - Lav histogram
n_unique <- length(unique(df[[col]]))
p <- ggplot(df, aes_string(x = col)) +
geom_histogram(bins = min(n_unique, 30), fill = 'skyblue', color = 'black', alpha = 0.7) +
labs(title = paste('Histogram of', col), x = col, y = 'Frequency') +
theme_minimal()
} else {
# Ikke-numeriske variabler - Lav bar plot
p <- ggplot(df, aes_string(x = col)) +
geom_bar(fill = 'orange', color = 'black', alpha = 0.7) +
labs(title = paste('Bar Plot of', col), x = col, y = 'Count') +
theme_minimal()
}
print(p) # Vis plottet
}#| '!! shinylive warning !!': |
#| shinylive does not work in self-contained HTML documents.
#| Please set `embed-resources: false` in your metadata.
#| standalone: true
#| viewerHeight: 600
library(shiny)
library(ggplot2)
data_before <- read.csv("https://raw.githubusercontent.com/Missing-almost-everywhere/Missing-almost-everywhere.io/main/Projects/house-prices-advanced-regression-techniqueshouse-prices-advanced-regression-techniques-data/data_before_clean.csv")
ui <- fluidPage(
titlePanel("House Prices Data Visualization"),
sidebarLayout(
sidebarPanel(
selectInput("variable", "Select Variable:", choices = names(data_before))
),
mainPanel(
plotOutput("dynamicPlot")
)
)
)
server <- function(input, output) {
output$dynamicPlot <- renderPlot({
col <- input$variable
if (is.numeric(data_before[[col]])) {
ggplot(data_before, aes(x = .data[[col]])) +
geom_histogram(bins = 30, fill = 'skyblue', color = 'black', alpha = 0.7) +
labs(title = paste('Histogram of', col), x = col, y = 'Frequency') +
theme_minimal()
} else {
ggplot(data_before, aes(x = .data[[col]])) +
geom_bar(fill = 'orange', color = 'black', alpha = 0.7) +
labs(title = paste('Bar Plot of', col), x = col, y = 'Count') +
theme_minimal()
}
})
}
shinyApp(ui = ui, server = server)Notes to historigrams
counts_df_MSSubClass <- as.data.frame(table(df$MSSubClass))
# Rename the columns for clarity
colnames(counts_df_MSSubClass) <- c("MSSubClass", "Count")
print(counts_df_MSSubClass) MSSubClass Count
1 20 536
2 30 69
3 40 4
4 45 12
5 50 144
6 60 299
7 70 60
8 75 16
9 80 58
10 85 20
11 90 52
12 120 87
13 160 63
14 180 10
15 190 30Id value are unique, and should not be incluede (it could have bin the case the same house hade bin sold multipuel times).
KitchenAbvGr is very skewed in distribution.
In this section i will list the varibels i have change and what the changes was.
Looking at the description of the data the varibesl with lowe count, is
Here is what i will combine them to.
40 will be combined with 50 - 50: 1-1/2 STORY FINISHED ALL AGES Making 1-1/2 STORY FINISHED ALL AGES
85 will be combined with 80 - 80: SPLIT OR MULTI-LEVEL Making Split
185 will be combined with 160 - 160: 2-STORY PUD - 1946 & NEWER Making PUD - MULTILEVEL
This only leaves 45: UNFINISHED ALL AGES
with a vary small number of obsevations, in this section we looking at the data but this kind of asumption will affect models choice, what is the value of unfinished house, alle ages. A unfinish house can either be a cheap way to get new house ore a extra expens since it proberly should be removed. Both of these would proberly have lower value than the 1-1/2 STORY FINISHED ALL AGES. So if i inclued them i can drag down the estimat for this groups, and this can be unproporsional if the model is fitted with least sqaur. If i dont comined it with a varibel want to use a interaction effect in linear model I will get model wiht a lot NA, where this the combinations is not represented, i can get around this by tackling overide the model, so basically get to make geuss in whose case, that could be the average house price, something more cleaver, so for now i will leave it in. If i have to do the overird i will tell, this is better than a zero score. In the total linear model this is not a problem, so i may be the case this not problem.
YearBuilt Som of this varibel is allready pressent in MSSubClass
GarageCars I have think about, it would give nice distribution if it was seplified belove ore equalt 2 cars with true and false. but i think their is more infomation in o zeror so the the varibel vill be zero, one, two, above 2
Looking at this it seam like it would be a god idear to cagaorise/colabse some of these varibel. This is to try to simplify the information. The problem that can arise is that with some of these varibels, they have such ueven distribution that, one can end up fitting a combination to uniqe house. this could be good fine but, in some case by colsaping one can better overall predictiv results. Later I will proberly reduce the dimension based on either spearman ore kendall tau corelation so one would want to ensure that if their is rank in the data is preserved. To give a exampel number of fireplace can be reduces to Yes or No. Yes would stille be higer than No.
fireplace siplified to binary yes and NO
PoolArea will be change to yes no their is not alot of information -pool yes No
For these i could it could potensiel be a good idear to eihter make fullbath total Halfbath total. ore colabs them in to yes no
Foundation will be combined by combin all other than “PConc” ore “CBlock” to “other”
LotConfig all other than Corner Inside will be combined
RoofStyle will be “Gable” or “other”
The one data point in MiscFeature that is tenis court will go under other
In Condition1 the following RRNe Within 200’ of East-West Railroad RRAe Adjacent to East-West Railroad RRNn Within 200’ of North-South Railroad RRAn Adjacent to North-South Railroad
Will be combied to (Near Railroad)
In the Exterior1st and Exterior2nd. Their is some catagories with single obsevations in, I will put them in the closet cagori.
I have rapt all the change in a function so it esay to aplly to the test dataset aswell
modify_df <- function(DF){
DF$MSSubClass[DF$MSSubClass == 40] <- 50
DF$MSSubClass[DF$MSSubClass == 85] <- 80
DF$MSSubClass[DF$MSSubClass == 185] <- 160
DF$have_Garage<-DF$GarageCars>0
DF$GarageCars<-NULL
# is Fireplace pressent
DF$Fireplaces_present<-DF$Fireplaces>0
DF$Fireplaces<-NULL
DF$FireplaceQu<-NULL
# is pool pressent
DF$pool_present<-DF$PoolArea>0
DF$PoolArea<-NULL
# Full bath pressent above ground
DF$FullBath_total<-DF$BsmtFullBath+DF$FullBath
DF$BsmtFullBath<-NULL
DF$FullBath<-NULL
DF$HalfBath_total<-DF$HalfBath+DF$BsmtHalfBath
DF$HalfBath<-NULL
DF$BsmtHalfBath<-NULL
DF$Alley<-NULL
DF$Fence<-DF$Fence!="No Fence"
DF$SaleCondition<-DF$SaleCondition=="Normal"
DF$LandContour<-DF$LandContour=="Lvl"
DF$LandSlope<-DF$LandSlope=="Gtl"
DF$Foundation[!(DF$Foundation %in% c("PConc", "CBlock"))] <- "Other"
DF$LotConfig[!(DF$LotConfig %in% c("Corner","Inside"))]<-"Other"
DF$RoofStyle<-DF$RoofStyle!="Gable"
DF$MiscFeature[DF$MiscFeature=="TenC"]<-"Othr"
DF$Condition1[DF$Condition1 %in% c("RRNe","RRAe","RRNn","RRAn")]<-"NR"
DF$Exterior1st[DF$Exterior1st=="AsphShn"]<-"AsbShng"
DF$Exterior1st[DF$Exterior1st=="CBlock"]<-"CemntBd"
DF$Exterior1st[DF$Exterior1st=="ImStucc"]<-"Stucco"
DF$Exterior2nd[DF$Exterior2nd=="CBlock"]<-"CemntBd"
DF$Exterior2nd[DF$Exterior2nd=="Other"]<-"plywood"
return(DF)
}
df=modify_df(df)
#df_test_for_choice<-modify_df(df_test_for_choice)
df_test_preformence<-modify_df(df_test_preformence)In this section, I will list the variables I plan to remove or disregard. The reason for their removal is that their distributions are very skewed compared to other variables, which I deem similar in the information they provide.
The main reason for disregarding these variables is that I do not believe they have high predictive strength, and I need to move forward with the data cleaning process. Also, I’m not getting paid for this.
X3SsnPorch no real information will be removed (removed)
ScreenPorch no information aviable will be removed
Alley contain no information and will be removed
street contain not information and will be removed
Utilities contain not information and will be removed
Condition2 contain not information and will be removed
RoofMatl contain not information and will be removed will be removed
Heating contain not information and will be removed will be removed
CentralAir contain not information and will be removed will be removed
PoolQC contain not information and will be removed will be removed
MiscFeature contain not information and will be removed will be removed
GarageQual
GarageCond
GarageType
Electrical
remove_varibels<-function(DF){
DF$X3SsnPorch<-NULL
DF$ScreenPorch<-NULL
DF$Alley<-NULL
DF$Street<-NULL
DF$Utilities<-NULL
DF$Condition2<-NULL
DF$RoofMatl<-NULL
DF$Heating<-NULL
DF$CentralAir<-NULL
DF$PoolQC<-NULL
DF$SaleType<-NULL
DF$GarageQual<-NULL
DF$GarageCond<-NULL
DF$GarageType<-NULL
DF$Electrical<-NULL
return(DF)
}
df=remove_varibels(df)
#df_test_for_choice<-remove_varibels(df_test_for_choice)
df_test_preformence<-remove_varibels(df_test_preformence)Below, I have plotted the variables remaining after the cleanup.
write.csv(df, "data_after_clean.csv", row.names = FALSE)library(ggplot2)
library(purrr)
for (col in names(df)) {
if (is.numeric(df[[col]])) {
# Numeriske variabler - Lav histogram
n_unique <- length(unique(df[[col]]))
p <- ggplot(df, aes_string(x = col)) +
geom_histogram(bins = min(n_unique, 30), fill = 'skyblue', color = 'black', alpha = 0.7) +
labs(title = paste('Histogram of', col), x = col, y = 'Frequency') +
theme_minimal()
} else {
# Ikke-numeriske variabler - Lav bar plot
p <- ggplot(df, aes_string(x = col)) +
geom_bar(fill = 'orange', color = 'black', alpha = 0.7) +
labs(title = paste('Bar Plot of', col), x = col, y = 'Count') +
theme_minimal()
}
print(p) # Vis plottet
}#| '!! shinylive warning !!': |
#| shinylive does not work in self-contained HTML documents.
#| Please set `embed-resources: false` in your metadata.
#| standalone: true
#| viewerHeight: 600
library(shiny)
library(ggplot2)
data_before <- read.csv("https://raw.githubusercontent.com/Missing-almost-everywhere/Missing-almost-everywhere.io/main/Projects/house-prices-advanced-regression-techniqueshouse-prices-advanced-regression-techniques-data/data_after_clean.csv")
ui <- fluidPage(
titlePanel("House Prices Data Visualization"),
sidebarLayout(
sidebarPanel(
selectInput("variable", "Select Variable:", choices = names(data_before))
),
mainPanel(
plotOutput("dynamicPlot")
)
)
)
server <- function(input, output) {
output$dynamicPlot <- renderPlot({
col <- input$variable
if (is.numeric(data_before[[col]])) {
ggplot(data_before, aes(x = .data[[col]])) +
geom_histogram(bins = 30, fill = 'skyblue', color = 'black', alpha = 0.7) +
labs(title = paste('Histogram of', col), x = col, y = 'Frequency') +
theme_minimal()
} else {
ggplot(data_before, aes(x = .data[[col]])) +
geom_bar(fill = 'orange', color = 'black', alpha = 0.7) +
labs(title = paste('Bar Plot of', col), x = col, y = 'Count') +
theme_minimal()
}
})
}
shinyApp(ui = ui, server = server)Below, I have plotted the correlation matrix for the variables. Since many of these variables are categorical but have a ranking, I used Spearman correlation.
df=na.omit(df)
library(corrplot)corrplot 0.95 loadedlibrary(Hmisc)
Attaching package: 'Hmisc'The following objects are masked from 'package:dplyr':
src, summarizeThe following objects are masked from 'package:base':
format.pval, unitsnumeric_df <- df[sapply(na.omit(df), is.numeric)]
# Compute Spearman correlation matrix
spearman_corr <- cor(numeric_df, method = "spearman")
# Compute p-values (optional)
library(Hmisc)
res <- rcorr(as.matrix(numeric_df), type = "spearman")
spearman_corr <- res$r # Correlation coefficients
# Plot the correlation matrix
corrplot(spearman_corr, method = "color",tl.col = "black", tl.srt = 60, insig = "blank",tl.cex = 0.5,title = "Spearman Correlation Plot")
Notes on the Plot Overall, the internal correlation is a lot smaller than I thought, which is good. This should make it easier to find good predictors.
The third variable from the bottom is the sales price. From this, one can see which variables could be potential predictors. It seems like OverallQual could be a really good predictor.
However, correlation only captures linear effects, so one should be cautious about relying solely on correlation for feature selection. Imagine there was a feature with a sinusoidal curve that perfectly described the data—it would have a correlation of zero.
In this section, I will reduce some variables, as multicollinearity can pose challenges for certain models. While some partitioning-based models are less sensitive to multicollinearity, linear models can be significantly impacted. In a simple linear model with two inputs, the variance of a parameter can be expressed as:
\[\text{Var}(\beta_1) = \frac{\sigma^2}{1 - \text{cor}(x_1, x_2)}\]
This means that as the correlation between two variables increases, the variance of the estimate explodes. Consequently, certain models are sensitive to multicollinearity.
One approach to addressing this is to remove variables with a correlation above a certain threshold. However, determining the optimal threshold is not straightforward. For a specific model, simulations can be conducted to estimate a suitable value. In this case, I want to perform some reduction before applying any models. I have chosen a cutoff point of (|0.7|). If there is a high correlation between two variables, I will remove the one with the weaker correlation to the log of the sale price.
Since the variables are not numeric but do have a ranking, PCA is not an option. However, Spearman correlation can still be used.
For variable reduction, hierarchical clustering can be applied using the absolute value of the Spearman correlations as a distance measure. Single-linkage clustering can then be employed, with a slight reformulation of the problem. Hierarchical clustering requires a distance metric, and for this purpose, the distance between two variables based on correlation can be defined as:
\(d(x_1, x_2) = 1 - |\text{cor}(x_1, x_2)|\)
Given the cutoff of (|0.7|) for correlation, the corresponding distance after reformulation would be:
\(1 - 0.7 = 0.3\)
# The code here is not optimized but it was fast to write
numeric_df <- df[sapply(na.omit(df), is.numeric)]
numeric_saleprice<-numeric_df$SalePrice
numeric_df$SalePrice<-NULL # remove from dataframe
library(Hmisc)
res <- rcorr(as.matrix(numeric_df), type = "spearman")
spearman_corr <- res$r # Correlation coefficients
dist_matrix <- as.dist(1-abs(spearman_corr))
hc <- hclust(dist_matrix, method = "single")
clusters <- cutree(hc, h = 0.3) #
# Visualize dendrogram
plot(hc, main = "Hierarchical Clustering Dendrogram")
abline(h = 0.3, col = "red") # Add cutoff line
# reduce varibels
numeric_saleprice_corr <- rcorr(as.matrix(numeric_df), numeric_saleprice, type = "spearman")#$r[, "numeric_saleprice"]
# Step 2: Identify clusters with multiple variables
duplicates <- table(clusters)[table(clusters) > 1]
clusters_with_duplicates <- names(duplicates)
for (cluster in clusters_with_duplicates) {
clusters_with_duplicates
n_cluster=length(names(clusters[clusters==cluster]))
spear_var=rep(NA,n_cluster)
names_cluster=names(clusters[clusters==cluster])
for (i in 1:n_cluster){
names(clusters[clusters==cluster])[i]
spear_var[i]=rcorr(as.matrix(numeric_df[names(clusters[clusters==cluster])[i]]),log(numeric_saleprice),type="spearman")$r[1,2]
}
index_of_max <- which.max(spear_var)
names_cluster[-index_of_max]
#numeric_df[names_cluster[-index_of_max]]<-NULL
df[names_cluster[-index_of_max]]<-NULL
#df_test_for_choice[names_cluster[-index_of_max]]<-NULL
df_test_preformence[names_cluster[-index_of_max]]<-NULL
}With the clusters found, for each cluster, the feature with the highest Spearman correlation to the log of the sale price will be chosen.
As a result, there was a reduction from 61 to 41 features.
numeric_df <- df[sapply(na.omit(df), is.numeric)]
numeric_saleprice<-numeric_df$SalePrice
numeric_df$SalePrice<-NULL # remove from dataframe
res <- rcorr(as.matrix(numeric_df), type = "spearman")
spearman_corr <- res$r # Correlation coefficients
dist_matrix <- as.dist(1-abs(spearman_corr))
hc <- hclust(dist_matrix, method = "single")
clusters <- cutree(hc, h = 0.3) #
# Visualize dendrogram
plot(hc, main = "Hierarchical Clustering Dendrogram")
abline(h = 0.3, col = "red") # Add cutoff line
As can be seen in the new dendrogram, the dataframe has been reduced to meet the requirements.
Below, I have ordered the variables based on the absolute value of their Spearman correlation.
# Required libraries
library(corrplot)
library(Hmisc)
# Subset the dataframe to numeric columns
numeric_df$log_saleprice<-log(df$SalePrice)
numeric_df$SalePrice<-NULL
# Ensure the target variable is present
target_variable <- "log_saleprice"
if (!target_variable %in% colnames(numeric_df)) {
stop("Target variable not found in numeric dataframe.")
}
# Compute Spearman correlation matrix and p-values
res <- rcorr(as.matrix(numeric_df), type = "spearman")
spearman_corr <- res$r # Correlation coefficients
# Extract correlation with the target variable
target_corr <- spearman_corr[, target_variable, drop = FALSE]
target_corr <- as.data.frame(target_corr)
colnames(target_corr) <- "Spearman_Correlation"
# Add a column indicating if the correlation could be computed
target_corr$Computed <- !is.na(target_corr$Spearman_Correlation)
# Sort variables by Spearman correlation in descending order
sorted_corr <- target_corr[order(abs(target_corr$Spearman_Correlation), decreasing = TRUE), ]
# Display sorted variables with their correlation and computed status
print(sorted_corr[1:10,]) Spearman_Correlation Computed
log_saleprice 1.0000000 TRUE
OverallQual 0.8087095 TRUE
GrLivArea 0.7304531 TRUE
BsmtQual 0.6760372 TRUE
GarageArea 0.6477811 TRUE
FullBath_total 0.6371933 TRUE
GarageFinish 0.6323531 TRUE
TotalBsmtSF 0.6023901 TRUE
YearRemodAdd 0.5688537 TRUE
HeatingQC 0.4906598 TRUELook at the Year sold the collation is really low. the spand of the years it relly lowe, this would idicate that the price do not raise a lot over time in this area. I would have expted some kind of increase to compensate for inflation.
Below i have recoded the Time as months since 2006, 1 being january. I also plottet logsale price as agianst the month
library(ggplot2)
library(dplyr)
numeric_df$time<-NA
for (i in 1:length(df$MoSold)){
numeric_df$time[i]<-(numeric_df$YrSold[i]-2006)*12+numeric_df$MoSold[i]
}
yearly_means <- numeric_df %>%
group_by(time) %>%
summarise(mean_value = mean(log_saleprice))
# Plot residuals against time
ggplot(data=numeric_df[!is.na(numeric_df$log_saleprice),], aes(x=numeric_df$time, y=log_saleprice)) +
geom_point(alpha = 0.6, color = "black") + # Individual data points
geom_line(data = yearly_means, aes(x = time, y = mean_value, color = "Mean Sold Price"),
size = 1, show.legend = TRUE) +
geom_point(data = yearly_means, aes(x = (time), y = mean_value),
color = "red", size = 2) +
labs(
x = "Month",
y = "Value",
title = "Monthly Data with Mean Overlay"
) +
theme_minimal()# caluculate mean 
monthly_means <- numeric_df %>%
group_by(MoSold) %>%
summarise(mean_value = mean(log_saleprice))
ggplot(data=numeric_df[!is.na(numeric_df$log_saleprice),], aes(x=numeric_df$MoSold, y=log_saleprice)) +
geom_point(alpha = 0.6, color = "black") + # Individual data points
geom_line(data = monthly_means, aes(x = MoSold, y = mean_value, color = "Mean Sold Price"),
size = 1, show.legend = TRUE) +
geom_point(data = monthly_means, aes(x = (MoSold), y = mean_value),
color = "red", size = 2) +
labs(
x = "Month",
y = "Value",
title = "Monthly Data with Mean Overlay"
) +
theme_minimal()
Overall their dont seam to be any big conettiction between pice and time. From the moth plot it clear if ther varinace of the price is dependen on the time ore if the salevolum changes letting to less spread.
OverallQual has high corelation with saleprice.
ggplot(data=df[!is.na(df$SalePrice),], aes(x=factor(OverallQual), y=log(SalePrice)))+
geom_point()+ labs(title="OverallQual")
log price seam linear related to overall quality.
Ground living area.
ggplot(data=df[!is.na(df$SalePrice),], aes(x=factor(GrLivArea), y=log(SalePrice)))+
geom_point()+ labs(title="GrLivArea")
Some of these variables do not have natural ordering, which means computing Spearman correlation is not possible. In that case, the best option (I know) is to plot the target variable against the categories in the variables. There are different forms, such as boxplots or violin plots. I have chosen violin plots since they have more resemblance to a histogram, which I prefer over boxplots.
write.csv(df, "data_for_final_model.csv", row.names = FALSE)library(dplyr)
library(ggplot2)
non_numeric_cols <- df %>%
select_if(~!is.numeric(.)) %>%
colnames()
for (col in non_numeric_cols) {
p <- ggplot(df, aes_string(x = col, y = "log(SalePrice)")) +
geom_violin() +
stat_summary(fun = "mean", geom = "point", color = "red", size = 3) + # Tilføj mean som rødt punkt
labs(title = paste("Violin plot for", col, "vs log(SalePrice)")) +
theme(axis.text.x = element_text(angle = 45, hjust = 1))
print(p) # Udskriv violin plot for hver iteration
}#| '!! shinylive warning !!': |
#| shinylive does not work in self-contained HTML documents.
#| Please set `embed-resources: false` in your metadata.
#| standalone: true
#| viewerHeight: 600
library(shiny)
library(ggplot2)
library(dplyr)
data_final <- read.csv("https://raw.githubusercontent.com/Missing-almost-everywhere/Missing-almost-everywhere.io/main/Projects/house-prices-advanced-regression-techniqueshouse-prices-advanced-regression-techniques-data/data_for_final_model.csv")
ui <- fluidPage(
titlePanel("None Numerical varibels"),
sidebarLayout(
sidebarPanel(
selectInput("variable", "Select Variable:",
choices = names(data_final))
),
mainPanel(
plotOutput("dynamicPlot")
)
)
)
server <- function(input, output) {
output$dynamicPlot <- renderPlot({
col <- input$variable
if (is.numeric(data_final[[col]])) {
if(col != "SalePrice") {
ggplot(data_final, aes(x = .data[[col]], y = log(SalePrice))) +
geom_point(alpha = 0.5) +
labs(title = paste(col, "vs log(SalePrice)")) +
theme_minimal()
} else {
ggplot(data_final, aes(x = .data[[col]])) +
geom_histogram(bins = 30, fill = 'skyblue', color = 'black', alpha = 0.7) +
labs(title = paste('Histogram of', col)) +
theme_minimal()
}
} else {
ggplot(data_final, aes(x = .data[[col]], y = log(SalePrice))) +
geom_violin(fill = 'skyblue', alpha = 0.7) +
stat_summary(fun = mean, geom = "point", color = "red", size = 3) +
labs(title = paste(col, "vs log(SalePrice)")) +
theme_minimal() +
theme(axis.text.x = element_text(angle = 45, hjust = 1))
}
})
}
shinyApp(ui = ui, server = server)
So what I am looking for is something their it seam like the means i sale price is different between the factors. Neighborhood, seam like a good varibel to include, in many intances on can see that the their is not even a overlab in the observed price.
The roofing seam like it could have potesial
I start by using some simple models, where I rely on intuition and examine the residuals. Then, I move on to more advanced techniques. First, I’m going to plot some models, analyze the residuals, and compare them to other variables. I like to start this way because it gives me an intuitive understanding of the data. Models built this way have the advantage of being easy to explain, which is helpful if someone wants to trade some predictive strength for better explainability. Personally, I still prioritize evaluating the models based on out-of-sample predictive strength, preferably using cross-validation.
After Plotting different models and looking the residual i found the below model. Where the saleprice pr sqft of living area is combination the Neighborhood the type of dwelling (MSSubClass).
Wich could be good candidate if one look the residuals being drawn from af t distribusion. So more heavy tale distribution, than a normal distribution. In many ways this model seam resanbull from a intuition point of view.
# Plot original data
model_baseline <-lm((SalePrice/GrLivArea) ~ TotalBsmtSF*MSSubClass:Neighborhood:GrLivArea , data = df) # lm((SalePrice / GrLivArea) ~ TotalBsmtSF+MSSubClass+Neighborhood,data=df)
plot(df$SalePrice,log(df$SalePrice)-log(model_baseline$fitted.value*df$GrLivArea))
hist(log(df$SalePrice)-log(model_baseline$fitted.value*df$GrLivArea),breaks=50)
# The histogram almost look like a t distribution
library(MASS)
fitdistr(log(df$SalePrice)-log(model_baseline$fitted.value*df$GrLivArea), "t",start = list(m=mean(log(df$SalePrice)-log(model_baseline$fitted.value*df$GrLivArea)),s=sd(log(df$SalePrice)-log(model_baseline$fitted.value*df$GrLivArea)), df=2),lower=c(-1, 0.001,1)) m s df
-0.009049068 0.156394619 4.526172860
( 0.004804025) ( 0.005221797) ( 0.565497406)library(Dowd)
TQQPlot(log(df$SalePrice)-log(model_baseline$fitted.value*df$GrLivArea),df=4.5 )
Belove I have fitted a interaction model where log saleprice is a interactiv funtion between, The type of house, the neighborhood and the size of the dewelling+ sum effect from the size of the basement. It seam reasonbell and is somewat how I would estimate a type of house for the overall price.
Model_second_baseline<- lm(log(SalePrice)~TotalBsmtSF+MSSubClass:GrLivArea:Neighborhood,data=df)
library(Dowd)
TQQPlot(Model_second_baseline$residuals,df=4.5 )
# Define the custom metric for CV evaluation
log_diff_metric_model_baseline <- function(data, label) {
groups=unique(label)
groups_score=rep(NA,length(groups))
for (i in 1:length(groups)){
groupe_for_test=groups[i]
partion_vector_train <- which(label!= groupe_for_test)
partion_vector_test <- which(label== groupe_for_test)
train_data <- data[partion_vector_train, ]
test_data <- data[partion_vector_test, ]
# fit model
model_baseline <-lm(log(SalePrice)~TotalBsmtSF+MSSubClass:GrLivArea:Neighborhood,data=train_data)
# get predition
predicted_SalePrice <- predict(model_baseline, newdata = test_data)
# get log diff
log_diff <- log(test_data$SalePrice) - (predicted_SalePrice)
# save results
groups_score[i]<-sum(log_diff**2)
}
return(sum(groups_score)/length(data$SalePrice))
}
# make labels
n_cv=50
labels=sample(rep(seq(1,n_cv),floor(length(df$Id)/n_cv)))
if(length(df$Id)-floor(length(df$Id)/n_cv)*n_cv!=0){
labels<-c(labels,seq(1:(length(df$Id)-floor(length(df$Id)/n_cv)*n_cv)))
}
labels=sample(labels)
print("RMSE of log prices")[1] "RMSE of log prices"print(log_diff_metric_model_baseline(df,labels))[1] 0.06427054Overall, the predictive strength looks good, but the residuals of the model resemble a t-distribution more than a normal distribution.
In this chunck of code i fit lasso model for the dataframe, by asuming a linear model over all the vearibels in the datafram penlized by the size of beta. The Lasso solves the following
\[\underset{\beta}{argmin} ||log(Y)-\beta X||_{2}^2+\lambda||\beta||_1\].
It penalizes the size of the coefficients (beta). Since the penalty is based on the \(L_1\) -norm, it tends to set some coefficients to zero. This encourages sparse solutions, where only the most relevant features are retained.
library(glmnet)
# Prepare the data
df_lasso <- df
log_saleprice <- log(df_lasso$SalePrice)
df_lasso$SalePrice <- NULL
df_lasso$log_saleprice <- log_saleprice # Add log_saleprice to df_lasso
df_lasso_id<-df_lasso$Id
df_lasso$Id<-NULL
# Remove rows with NA values
df_lasso <- na.omit(df_lasso)
# Split data into folds
k <- 10
folds <- sample(1:k, size = nrow(df_lasso), replace = TRUE)
# Initialize a vector to store MSEs for each fold
cv_mse <- numeric(k)
best_lambda_vector <- rep(NA, k)
for (i in 1:k) {
# Split data into training and test sets
train_indices <- which(folds != i)
test_indices <- which(folds == i)
train_data <- df_lasso[train_indices, ]
test_data <- df_lasso[test_indices, ]
# Create design matrices
X_train <- model.matrix(log_saleprice ~ . , data = train_data)
X_test <- model.matrix(log_saleprice ~ . , data = test_data)
# Fix column mismatch between X_train and X_test
common_columns <- intersect(colnames(X_train), colnames(X_test))
X_test <- X_test[, common_columns, drop = FALSE]
X_train <- X_train[, common_columns, drop = FALSE]
# Fit LASSO model with cross-validation to choose lambda
lasso_model <- cv.glmnet(X_train, train_data$log_saleprice, alpha = 1, family = "gaussian")
best_lambda <- lasso_model$lambda.min
best_lambda_vector[i] <- best_lambda
# Predict on test data
predictions <- predict(lasso_model, s = best_lambda, newx = X_test)
# Compute MSE for this fold
cv_mse[i] <- mean((test_data$log_saleprice - predictions)^2)
}
# Average MSE across all folds
mean_cv_mse <- mean(cv_mse)
cat("Mean Cross-Validated MSE:", mean_cv_mse, "\n")Mean Cross-Validated MSE: 0.02111107 # Fit final LASSO model with the average best lambda
mean_best_lambda <- mean(best_lambda_vector, na.rm = TRUE) # Calculate mean lambda
X_full <- model.matrix(log_saleprice ~ . , data = df_lasso)
final_lasso_model <- glmnet(X_full, log_saleprice, alpha = 1, lambda = mean_best_lambda, family = "gaussian")
# Print final model coefficients
print(mean_cv_mse)[1] 0.02111107As observed, the predictive strength of the model is better than the baseline model, but not by a lot in terms of predictive performance.
XGBoost is an ensemble learning method that uses repeated decision trees, where each tree is fitted on the residuals of the previous one. Essentially, it’s a sophisticated method of partitioning the dataset.
This approach has gained significant popularity, so I decided to give it a try. Since XGBoost relies on tree structures for partitioning, the data must have an inherent ordering. To include categorical variables, I applied one-hot encoding to transform them into a suitable format.
library(xgboost)
library(data.table)
# Prepare the dataset
df_xgb <- df
target <- log(df_xgb$SalePrice) # Log-transform the target variable
df_xgb$SalePrice <- NULL # Remove the target variable from features
df_xgb_Id <- df_xgb$Id
df_xgb$Id <- NULL
# One-hot encode categorical variables
df_xgb <- as.data.table(df_xgb)
df_xgb <- model.matrix(~ . - 1, data = df_xgb) # Perform one-hot encoding and remove intercept
# Create DMatrix
ddata <- xgb.DMatrix(data = df_xgb, label = target)
# Set parameters for the XGBoost model
params <- list(
objective = "reg:squarederror", # Regression task
eta = 0.1, # Learning rate
max_depth = 6, # Maximum depth of trees
subsample = 0.8, # Subsampling ratio
colsample_bytree = 0.8 # Feature subsampling ratio
)
# Perform 10-fold cross-validation
set.seed(123) # For reproducibility
cv_results <- xgb.cv(
params = params,
data = ddata,
nrounds = 100, # Number of boosting rounds
nfold = 10, # Number of folds for cross-validation
metrics = "rmse", # Evaluation metric
early_stopping_rounds = 10, # Stop early if no improvement
print_every_n = 10, # Print progress every 10 rounds
verbose = TRUE
)[1] train-rmse:10.379960+0.002592 test-rmse:10.379961+0.026888
Multiple eval metrics are present. Will use test_rmse for early stopping.
Will train until test_rmse hasn't improved in 10 rounds.
[11] train-rmse:3.637180+0.001203 test-rmse:3.637569+0.017285
[21] train-rmse:1.286535+0.000669 test-rmse:1.287011+0.011197
[31] train-rmse:0.469571+0.000640 test-rmse:0.476945+0.007929
[41] train-rmse:0.190574+0.000775 test-rmse:0.215138+0.012590
[51] train-rmse:0.102444+0.000572 test-rmse:0.147398+0.018300
[61] train-rmse:0.075914+0.000609 test-rmse:0.132825+0.019453
[71] train-rmse:0.065099+0.000603 test-rmse:0.129387+0.019381
[81] train-rmse:0.057990+0.001078 test-rmse:0.128064+0.019680
[91] train-rmse:0.052257+0.001140 test-rmse:0.127166+0.019725
[100] train-rmse:0.047739+0.001064 test-rmse:0.126684+0.019586 # Extract the best number of boosting rounds
best_nrounds <- cv_results$best_iteration
cat("Best number of rounds:", best_nrounds, "\n")Best number of rounds: 98 # Train final model using the best number of rounds
final_model <- xgb.train(
params = params,
data = ddata,
nrounds = best_nrounds
)
# Evaluate final model on entire dataset (or split as desired)
predictions <- predict(final_model, ddata)
overall_rmse <- sqrt(mean((target - predictions)^2))
cat("RMSE on entire dataset:", overall_rmse, "\n")RMSE on entire dataset: 0.05299007 Overall, it seems like the best option is the lasso model for prediction.
There are some missing values, which I address using the K-Nearest Neighbors (KNN) algorithm. This method is particularly effective for handling missing values in categorical variables.
print("df_test_preformence")[1] "df_test_preformence"table(df_test_preformence$MSSubClass)
20 30 45 50 60 70 75 80 90 120 150 160 180 190
543 70 6 145 276 68 7 88 57 95 1 65 7 31 print("df")[1] "df"table(df$MSSubClass)
20 30 45 50 60 70 75 80 90 120 160 180 190
532 67 12 148 296 60 16 78 52 86 63 10 30 df_test_preformence$MSSubClass[df_test_preformence$MSSubClass==150]=160missing values
vis_miss(df_test_preformence)
library(VIM)Warning: package 'VIM' was built under R version 4.4.2Loading required package: colorspaceLoading required package: gridVIM is ready to use.Suggestions and bug-reports can be submitted at: https://github.com/statistikat/VIM/issues
Attaching package: 'VIM'The following object is masked from 'package:bootstrap':
diabetesThe following object is masked from 'package:datasets':
sleep# Impute missing values using KNN
imputed_data <- kNN(df_test_preformence, k = 5)
# the imputed_data ad a new colum to say what vaules is imputed i am remvoving them.
df_test_preformence<-imputed_data[,1:dim(df_test_preformence)[2]]
# Check the updated dataframe
dim(df_test_preformence)[1] 1459 54Their is one Plywood in test set
setdiff(unique(df$Exterior2nd),unique(df_test_preformence$Exterior2nd))[1] "plywood"table(df_test_preformence$Exterior2nd)
AsbShng AsphShn Brk Cmn BrkFace CemntBd CmentBd HdBoard ImStucc MetalSd Plywood
18 1 15 22 2 66 199 5 233 128
Stone Stucco VinylSd Wd Sdng Wd Shng
1 21 511 194 43 table(df$Exterior2nd)
AsbShng AsphShn Brk Cmn BrkFace CemntBd CmentBd HdBoard ImStucc MetalSd plywood
20 3 7 25 1 58 207 10 213 1
Plywood Stone Stucco VinylSd Wd Sdng Wd Shng
142 4 26 499 196 38 X_full <- model.matrix(log_saleprice ~ . , data = df_lasso)
final_lasso_model <- glmnet(X_full, df_lasso$log_saleprice, alpha = 1, lambda = mean_best_lambda, family = "gaussian")
df_lasso_evalatio <- df_test_preformence
df_lasso_evalatio_id<-df_lasso_evalatio$Id
df_lasso_evalatio$Id<-NULL
# Create design matrix for prediction from test data
X_predict <- model.matrix(~., data = df_lasso_evalatio)
# Identify any missing columns between X_full and the prediction data (X_predict)
missing_cols <- setdiff(colnames(X_full), colnames(X_predict))
# Add missing columns to X_predict with zero values (align columns)
X_predict <- cbind(X_predict, matrix(0, nrow = nrow(X_predict), ncol = length(missing_cols),
dimnames = list(NULL, missing_cols)))
# Ensure column order matches X_full
X_predict <- X_predict[, colnames(X_full)]
# Predict log_saleprice for the test dataset
predictions <- predict(final_lasso_model, newx = X_predict)
# Convert log predictions to SalePrice scale (exp of log predictions)
SalePrice_pred <- exp(c(predictions))
# Create a data frame with Id and SalePrice
prediction_df <- data.frame(Id = df_lasso_evalatio_id, SalePrice = SalePrice_pred)
# Write predictions to a CSV file
#write.csv(prediction_df, "sale_prices.csv", row.names = FALSE)
# Check the length of SalePrice predictions
length(prediction_df$SalePrice)[1] 1459Overall, the score is good, and I’ve noticed that many people achieve a similar score. On the leaderboards, a score of 0.00044 can be found, which I find oddly low. Apparently, this is because the same dataset is used for another project some Boston dataset, and people are finding the corresponding test values there.
I achieved a score of 0.13755, which is good but might be improved by using a superlearner or performing regression on the predictive values from different models.
I liked it was the lasso that is chosen since i vary esay to interipted, wich i nice.
Comments on Available Data
All the houses are located in the Ames city area. There is information on the month and year sold. (In both the training and test sets, the years have the same values, meaning there’s no need to estimate values forward in time. This is a bit unusual—what is the purpose of the model in such a case?) Most of the data is categorical or discrete in nature. Some of the data has a natural order or rank. When examining the available data, it’s worth noting that there is no information on earlier sale prices—why is this missing? Information on “time on market” is also missing.